home *** CD-ROM | disk | FTP | other *** search
/ Amiga Collections: Camelot / Camelot 098 (1990-12)(Swedish User Group of Amiga)(SE)(PD)[WB].zip / Camelot 098 (1990-12)(Swedish User Group of Amiga)(SE)(PD)[WB].adf / XLisp-Stat / dialogs.lsp < prev    next >
Lisp/Scheme  |  1990-10-03  |  13KB  |  336 lines
  1. ;;;;
  2. ;;;; graphics.lsp XLISP-STAT custom dialog objects and functions
  3. ;;;; XLISP-STAT 2.1 Copyright (c) 1990, by Luke Tierney
  4. ;;;; Additions to Xlisp 2.1, Copyright (c) 1989 by David Michael Betz
  5. ;;;; You may give out copies of this software; for conditions see the file
  6. ;;;; COPYING included with this distribution.
  7. ;;;;
  8.  
  9. (provide "dialogs")
  10.  
  11. ;;;;
  12. ;;;;
  13. ;;;; OK-or-Cancel Dialog Prototype
  14. ;;;;
  15. ;;;;
  16.  
  17. (defproto ok-or-cancel-dialog-proto 
  18.   '(ok-button cancel-button) () modal-dialog-proto)
  19.  
  20. (defmeth ok-or-cancel-dialog-proto :isnew (items &rest args
  21.                                                  &key (ok-default t) 
  22.                                                  (ok-action #'(lambda () t))
  23.                                                  (cancel-action 
  24.                                                   #'(lambda () nil)))
  25.   (let ((items (if (consp items) items (list items)))
  26.         (ok-button (send modal-button-proto :new "OK" 
  27.                          :action ok-action))
  28.         (cancel-button (send modal-button-proto :new "Cancel"
  29.                              :action cancel-action)))
  30.     (setf items (mapcar #'(lambda (x) 
  31.                                   (if (stringp x) 
  32.                                       (send text-item-proto :new x)
  33.                                       x))
  34.                         items))
  35.     (setf (slot-value 'ok-button) ok-button)
  36.     (setf (slot-value 'cancel-button) cancel-button)
  37.     (apply #'call-next-method
  38.            (append items (list (list ok-button cancel-button)))
  39.            args)
  40.     (send self :default-button (if ok-default ok-button cancel-button))))
  41.   
  42. (defun ok-or-cancel-dialog (s &optional (ok-default t) &rest args)
  43. "Args: (s &optional (ok-default t) &rest args)
  44. Open modal dialog with string S and OK, Cancel buttons. Returns T for
  45. OK, NIL for Cancel. S can contain format directives, which are filled
  46. from the remaining arguments."
  47.   (let ((d (send ok-or-cancel-dialog-proto :new 
  48.                  (apply #'format nil s args) :ok-default ok-default)))
  49.     (send d :modal-dialog)))
  50.  
  51. ;;;;
  52. ;;;;
  53. ;;;; Message Dialog Prototype
  54. ;;;;
  55. ;;;;
  56.  
  57. (defproto message-dialog-proto '() () modal-dialog-proto)
  58.  
  59. (defmeth message-dialog-proto :isnew (s)
  60.   (let ((text (if (consp s) s (list s)))
  61.         (ok-button (send modal-button-proto :new "OK")))
  62.     (call-next-method (append text (list ok-button)))
  63.     (send self :default-button ok-button)))
  64.   
  65. (defun message-dialog (&rest args)
  66. "Args: (s &rest args)
  67. Open modal dialog with string S and OK buttons. Returns NIL. S can contain
  68. format directives, which are filled from the remaining arguments."
  69.   (let ((d (send message-dialog-proto :new (apply #'format nil args))))
  70.      (send d :modal-dialog)))
  71.  
  72. ;;;;
  73. ;;;;
  74. ;;;; Get String/Value Dialog Prototype
  75. ;;;;
  76. ;;;;
  77.  
  78. (defproto get-string-dialog-proto () () ok-or-cancel-dialog-proto)
  79.  
  80. (defmeth get-string-dialog-proto :isnew (s &rest args &key (initial nil has-init))
  81.   (let* ((prompt-item (send text-item-proto :new s))
  82.          (edit-item (send edit-text-item-proto :new 
  83.                           (if has-init (format nil "~a" initial) "")
  84.                           :text-length 20)))
  85.     (apply #'call-next-method 
  86.            (list prompt-item edit-item)
  87.            :ok-action #'(lambda () (send edit-item :text))
  88.            args)))
  89.  
  90. (defun get-string-dialog (&rest args)
  91. "Args: (s &key initial)
  92. Opens a modal dialog with prompt S, a text field and OK, Cancel buttons.
  93. INITIAL is converted to a string with ~A format directive. Returns string
  94. of text field content on OK, NIL on cancel."
  95.   (let ((d (apply #'send get-string-dialog-proto :new args)))
  96.     (send d :modal-dialog)))
  97.  
  98. (defun get-value-dialog (prompt &rest args &key (initial "" supplied))
  99. "Args: (s &key initial)
  100. Opens a modal dialog with prompt S, a text field and OK, Cancel buttons.
  101. INITIAL is converted to a string with ~S format directive. On Cancel returns
  102. NIL. ON OK Returns list of result of reading and eval'ing the text field's
  103. content."
  104.   (let* ((initial (if supplied
  105.                       (format nil "~s" initial)
  106.                       initial))
  107.          (s (apply #'get-string-dialog prompt :initial initial args)))
  108.     (if s (list (eval (read (make-string-input-stream s) nil))))))
  109.       
  110. ;;;;
  111. ;;;;
  112. ;;;; Choose string/value dialog prototype
  113. ;;;;
  114. ;;;;
  115.  
  116. (defproto choose-item-dialog-proto () () ok-or-cancel-dialog-proto)
  117.  
  118. (defmeth choose-item-dialog-proto :isnew (s strings &rest args 
  119.                                             &key (initial 0))
  120.   (let* ((prompt-item (send text-item-proto :new s))
  121.          (string-item (send choice-item-proto :new strings :value initial)))
  122.     (apply #'call-next-method (list prompt-item string-item)
  123.            :ok-action #'(lambda () (send string-item :value))
  124.            args)))
  125.  
  126. (defun choose-item-dialog (&rest args)
  127. "Args: (s strings &key initial)
  128. Opens modal dialog with prompt S, a choice item for list of strings STRINGS
  129. and OK, Cancel buttons. Returns chosen string on OK, NIL on cancel."
  130.   (let ((d (apply #'send choose-item-dialog-proto :new args)))
  131.     (send d :modal-dialog)))
  132.  
  133. ;;;;
  134. ;;;;
  135. ;;;; Choose string/value dialog prototype
  136. ;;;;
  137. ;;;;
  138.  
  139. (defproto choose-subset-dialog-proto () () ok-or-cancel-dialog-proto)
  140.  
  141. (defmeth choose-subset-dialog-proto :isnew (s strings &rest args
  142.                                               &key (initial nil))
  143.   (let ((prompt-item (send text-item-proto :new s))
  144.         (subset-items (mapcar #'(lambda (x y) 
  145.                                   (send toggle-item-proto
  146.                                         :new x :value (member y initial)))
  147.                               strings (iseq 0 (- (length strings) 1)))))
  148.     (apply #'call-next-method (cons prompt-item subset-items)
  149.            :ok-action #'(lambda () 
  150.                           (list (which (mapcar #'(lambda (x) (send x :value))
  151.                                                subset-items))))
  152.            args)))
  153.  
  154. (defun choose-subset-dialog (&rest args)
  155. "Args: (s strings &key initial)
  156. Opens modal dialog with prompt S, a set of toggle items for list of 
  157. strings STRINGS, and OK, Cancel buttons. Returns list of list of indices
  158. of chosen items on OK, NIL on cancel."
  159.   (let ((d (apply #'send choose-subset-dialog-proto :new args)))
  160.     (send d :modal-dialog)))
  161.  
  162. ;;;;
  163. ;;;;
  164. ;;;; Sequence Scroll Bar Item Prototype
  165. ;;;;
  166. ;;;;
  167.  
  168. (defproto sequence-scroll-item-proto 
  169.   '(sequence display-sequence value-text-item) () scroll-item-proto)
  170.  
  171. (defmeth sequence-scroll-item-proto :isnew 
  172.   (x &key text-item (size '(180 16)) location action display)
  173.   (let* ((sequence (coerce x 'vector))
  174.          (display (if display (coerce display 'vector) sequence)))
  175.     (setf (slot-value 'sequence) sequence)
  176.     (setf (slot-value 'display-sequence) display)
  177.     (setf (slot-value 'value-text-item) text-item)
  178.     (call-next-method :size size 
  179.                       :location location
  180.                       :min-value 0 :max-value (1- (length sequence))
  181.                       :page-increment 5
  182.                       :action action)))
  183.               
  184. (defmeth sequence-scroll-item-proto :scroll-action ()
  185.   (send self :display-value)
  186.   (send self :user-action))
  187.  
  188. (defmeth sequence-scroll-item-proto :do-action ()
  189.   (send self :display-value)
  190.   (send self :user-action))
  191.  
  192. (defmeth sequence-scroll-item-proto :value (&optional (val nil set))
  193.   (when set (call-next-method val) (send self :display-value))
  194.   (call-next-method))
  195.  
  196. (defmeth sequence-scroll-item-proto :display-value ()
  197.   (if (slot-value 'value-text-item) 
  198.       (send (slot-value 'value-text-item) :text 
  199.             (format nil "~s" 
  200.                     (elt (slot-value 'display-sequence) 
  201.                          (send self :value))))))
  202.  
  203. (defmeth sequence-scroll-item-proto :user-action ()
  204.   (if (slot-value 'action)
  205.       (funcall (slot-value 'action)
  206.                (elt (slot-value 'sequence) (send self :value)))))
  207.   
  208. ;;;;
  209. ;;;;
  210. ;;;; Sequence Slider Dialog Prototype
  211. ;;;;
  212. ;;;;
  213.  
  214. (defproto sequence-slider-dialog-proto () () dialog-proto)
  215.  
  216. (defmeth sequence-slider-dialog-proto :isnew 
  217.   (data &key (text "Value") (title "Slider") action display)
  218.   (let* ((name-item (send text-item-proto :new text))
  219.          (value-item (send text-item-proto :new "          "
  220.                            :location '(100 5)))
  221.          (scroll-item (send sequence-scroll-item-proto :new data 
  222.                             :text-item value-item
  223.                             :action action :display display)))
  224.     (call-next-method (list name-item value-item scroll-item) :title title)
  225.     (send scroll-item :display-value)))
  226.  
  227. (defmeth sequence-slider-dialog-proto :value (&rest args)
  228.   (apply #'send (nth 2 (slot-value 'items)) :value args))
  229.  
  230. (defun sequence-slider-dialog (&rest args)
  231. "Args: (data &key (text \"Value\") (title \"Slider\") action display)
  232. Opens modeless dialog with title TITLE, prompt TEXT, a text display and a
  233. scrollbar. The scrollbar scrolls through the DATA sequence and displays the
  234. corresponding element of the DISPLAY sequence. When a scroll event occurs
  235. ACTION is called with the current value of DATA as argument."
  236.   (apply #'send sequence-slider-dialog-proto :new args))
  237.  
  238.  
  239. ;;;;
  240. ;;;;
  241. ;;;; Interval Scroll Bar Item Prototype
  242. ;;;;
  243. ;;;;
  244.  
  245. (defproto interval-scroll-item-proto 
  246.   '(interval num-points value-text-item) () scroll-item-proto)
  247.  
  248. (defmeth interval-scroll-item-proto :isnew 
  249.   (x &key text-item (size '(180 16)) location action
  250.           (points (nth 2 (get-nice-range (nth 0 x) (nth 1 x) 50))))
  251.   (setf (slot-value 'interval) x)
  252.   (setf (slot-value 'num-points) points)
  253.   (setf (slot-value 'value-text-item) text-item)
  254.   (call-next-method :size size :location location :min-value 0
  255.                     :max-value (1- points)
  256.                     :action action))
  257.               
  258. (defmeth interval-scroll-item-proto :value (&optional (val nil set))
  259.   (let ((interval (slot-value 'interval))
  260.         (num-points (slot-value 'num-points)))
  261.     (if set 
  262.         (let* ((min (elt interval 0))
  263.                (max (elt interval 1))
  264. ;              (val (floor (* (1- num-points) (/ (- val min) (- max min))))))
  265. ; changed for more accuracy JKL
  266.                (val (floor (/ (* (1- num-points) (- val min)) (- max min)))))
  267.           (call-next-method val)
  268.           (send self :display-value)
  269.           (send self :user-action)))
  270.     (let ((min (elt interval 0))
  271.           (max (elt interval 1)))
  272.       (+ min (* (/ (call-next-method) (1- num-points)) (- max min))))))
  273.  
  274. (defmeth interval-scroll-item-proto :max (&optional (max nil set))
  275.   (let ((value (send self :value)))
  276.     (when set (setf (elt interval 1) max) (send self :value value))
  277.     (elt interval 1)))
  278.     
  279. (defmeth interval-scroll-item-proto :min (&optional (min nil set))
  280.   (let ((value (send self :value)))
  281.     (when set (setf (elt interval 0) min) (send self :value value))
  282.     (elt interval 0)))
  283.  
  284. (defmeth interval-scroll-item-proto :user-action ()
  285.   (if (slot-value 'action)
  286.       (funcall (slot-value 'action) (send self :value))))
  287.   
  288. (defmeth interval-scroll-item-proto :display-value ()
  289.   (if (slot-value 'value-text-item)
  290.       (send (slot-value 'value-text-item)
  291.             :text (num-to-string (send self :value)))))
  292.  
  293. (defmeth interval-scroll-item-proto :scroll-action ()
  294.   (send self :display-value)
  295.   (send self :user-action))
  296.  
  297. (defmeth interval-scroll-item-proto :do-action ()
  298.   (send self :display-value)
  299.   (send self :user-action))
  300.  
  301. ;;;;
  302. ;;;;
  303. ;;;; Interval Slider Dialog Prototype
  304. ;;;;
  305. ;;;;
  306.  
  307. (defproto interval-slider-dialog-proto () () dialog-proto)
  308.  
  309. (defmeth interval-slider-dialog-proto :isnew 
  310.   (data &key (text "Value") (title "Slider") action (points 30) (nice t))
  311.   (if nice
  312.       (let ((range (get-nice-range (nth 0 data) (nth 1 data) points)))
  313.         (setq data (list (nth 0 range) (nth 1 range)))
  314.         (setq points (nth 2 range))))
  315.   (let* ((value-item (send text-item-proto :new "              "
  316.                            :location '(100 5)))
  317.          (name-item (send text-item-proto :new text))
  318.          (scroll-item (send interval-scroll-item-proto :new data 
  319.                             :text-item value-item
  320.                             :action action :points points)))
  321.     (call-next-method (list name-item value-item scroll-item) :title title)
  322.     (send scroll-item :display-value)))
  323.  
  324. (defmeth interval-slider-dialog-proto :value (&rest args)
  325.   (apply #'send (nth 2 (slot-value 'items)) :value args))
  326.  
  327. (defun interval-slider-dialog (&rest args)
  328. "Args: (data &key (text \"Value\") (title \"Slider\") action (points 30) (nice t))
  329. Opens modeless dialog with title TITLE, prompt TEXT, a text display and a
  330. scrollbar. The scrollbar scrolls through the interval DATA, a list of the form
  331. (LOW HIGH), sequence and displays the value. When a scroll event occurs
  332. ACTION is called with the current value in the interval as argument. If NICE
  333. is not NIL DATA and POINTS are revised to produce a nice set of values."
  334.   (apply #'send interval-slider-dialog-proto :new args))
  335.  
  336.